COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DE AZERTYOP ( PHRASE)
C00011 ENDMK
C⊗;
(DE AZERTYOP (;; PHRASE)
  (PRINT '(AZERTYOP : BJOUR MSIEU))
  (SETQ WORD NIL DABA [['DABA]] FOCUS NIL #OBJ NIL #REL NIL #LOC NIL)
  (WHILE (NOT (EQUAL (SETQ PHRASE (READ)) '(BYE)))
         (OR (EVAL-NET (GET 'PHRASE 'NET) PHRASE)
             (PRINT '(AZERTYOP : ZAI RIEN COMPRIS MSIEU))))
  '(AZERTYOP : RVOIR MSIEU))

(DE EVAL-NET (NET PHRASE) (COND
  ((NULL NET) NIL)
  ((EVAL-CLAUSE (CAR NET) PHRASE))
  (T (EVAL-NET (CDR NET) PHRASE))))

(DE EVAL-CLAUSE (CLAUSE PHRASE)
  (IF (NULL CLAUSE) (LIST PHRASE)
      (SETQ LASTWORD WORD WORD (CAR PHRASE))
      (IF (ATOM (CAR CLAUSE))
          (IF (EQ (NEXTL CLAUSE) WORD)
              (EVAL-CLAUSE CLAUSE (CDR PHRASE)))
          (SELECTQ (CAAR CLAUSE)
            ($ACT (EPROGN (CDAR CLAUSE)) (EVAL-CLAUSE (CDR CLAUSE) PHRASE))
            ($OR (IF (MEMQ WORD (CDAR CLAUSE))
                     (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
            ($TEST (IF (EVAL (CADAR CLAUSE))
                       (EVAL-CLAUSE (CDR CLAUSE) (CDR PHRASE))))
	    ($CALL (SETQ AUX (EVAL-NET (GET (CADAR CLAUSE) 'NET) PHRASE))
   	           (IF AUX (EVAL-CLAUSE (CDR CLAUSE) (CAR AUX))))
            ()
  ))))))))))))))))))

(DF DEF-NET (L) (PUT (CAR L) (CDR L) 'NET))

(DEF-NET PHRASE
 (VOYONS ($ACT (SCENE)))
 (($CALL NG) ($ACT (SETQ #OBJ #NG))
  EST ($CALL LIEU) ($ACT (DECLARATIVE)))
 (PREND ($CALL NG-LE) ($ACT (SETQ #OBJ #NG) (IMPER-1)))
 (($OR MET POSE) ($CALL NG-LE) ($ACT (SETQ #OBJ #NG))
  ($CALL LIEU) ($ACT (IMPER-2)))
 (OU EST ($CALL NG-IL) ($ACT (SETQ #OBJ #NG)(WHERE-Q)))
 (($OR DE DU) ($CALL NG) ($ACT (FOCUS-IT #NG) (P-OUI-MSIEUR)))
 )

(DEF-NET NG
 (($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 (LE CUBE ($TEST (NUMBP WORD)) ($ACT (SETQ #NG LASTWORD)))
 )

(DEF-NET LIEU
 (PAR TERRE ($ACT (SETQ #LOC 'TERRE #REL 'SUR)))
 (SUR ($ACT (SETQ #REL 'SUR)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 (SOUS ($ACT (SETQ #REL 'SOUS)) ($CALL NG-LUI) ($ACT (SETQ #LOC #NG)))
 )

(DEF-NET NG-LE
  (($CALL NG))
  (LE ($ACT (SOLVE)))
  )

(DEF-NET NG-IL
  (($CALL NG))
  (IL ($ACT (SOLVE)))
  )

(DEF-NET NG-LUI
  (($CALL NG))
  (LUI ($ACT (SOLVE)))
  )

(DE PRESENT (-P- DABA) (COND
  ((NULL DABA) NIL)
  ((MATCH -P- (NEXTL DABA)))
  (T (PRESENT -P- DABA))))

(DE MATCH (-P- -D-) (COND
  ((AND (NULL -P-) (NULL -D-)) T)
  ((OR (NULL -P-) (NULL -D-)) NIL)
  ((ATOM (CAR -P-)) (IF (EQ (NEXTL -P-) (NEXTL -D-))
                        (MATCH -P- -D-)))
  ((EQ (CAAR -P-) '/,)
   (MATCH (CONS (EVAL (CADAR -P-)) (CDR -P-)) -D-))
  ((EQ (CAAR -P-) '/!)
   (IF (MATCH (CDR -P-) (CDR -D-))
       (SET (CADAR -P-) (CAR -D-))))))))))))))))

(STATUS 18 '/! '(LAMBDA () (LIST '/! (READ))))
(STATUS 18 '/, '(LAMBDA () (LIST '/, (READ))))

(DE PRINZ L
  (PRINT (APPEND '(AZERTYOP :) L)))

(DE SCENE () (MAPC DABA 'PRINT)
  (IF (PRESENT '(!X MAIN) DABA) (PRINT 'ET 'JE 'TIENS X)))

(DE SOLVE () (SETQ #NG (NEXTL FOCUS)))

(DE IN-DABA (X) (SETQ DABA (CONS X DABA)))
(DE OUT-DABA (X) (OUDA X DABA))
(DE OUDA (X DB) (IF (EQUAL X (CAR DB)) (RPLACB DB (CDR DB))
                    (OUDA X (CDR DB))))

(DE P-ABSURDE ()
  (PRINZ 'C/'EST 'SAUF 'VOT 'RESPECT 'MSIEU 'ABSURDE))
(DE P-DE-QUI ()
  (PRINZ 'DE 'QUI 'VOUS 'CAUSEZ 'MSIEU '/?))
(DE P-YAPAS (X)
  (PRINZ 'YA 'PAS 'DE X 'MSIEU))
(DE P-OUI-MSIEU ()
  (PRINZ 'OUI 'MSIEU 'COMPRIS 'MSIEU))

(DE FOCUS-IT (X) (SETQ FOCUS (CONS X FOCUS)))

(DE DECLARATIVE () (COND
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((DECL DABA))))

(DE DECL (DB) (COND
  ((NULL DB) (IN-DABA (LIST #OBJ 'SUR #LOC)) (FOCUS-IT #OBJ) (P-OUI-MSIEU))
  ((MEMQ #OBJ (NEXTL DB)) (PRINZ #OBJ 'EXISTE 'DEJA 'MSIEU))
  (T (DECL DB))))

(DE IMPER-1 () (COND
  ((NULL #OBJ) (P-DE-QUI))
  ((PRESENT '(!X SUR ,#OBJ) DABA)
   (PRINZ 'JPEU 'PAS 'MSIEU 'YA X 'DESSUS) (FOCUS-IT X))
  ((PRESENT '(!X MAIN) DABA) (COND
    ((EQ X #OBJ) (PRINZ 'JELTIEN 'DEJA 'MSIEU) (FOCUS-IT #OBJ))
    (T (PRINZ 'CAISSE 'QUEJFAI 'DE X 'MSIEU '/?) (FOCUS-IT X))))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (OUT-DABA (LIST #OBJ 'SUR X)) (IN-DABA (LIST #OBJ 'MAIN))
   (FOCUS-IT #OBJ) (P-OUI-MSIEU))
   (T (FOCUS-IT #OBJ) (P-YAPAS #OBJ))))

(DE WHERE-Q ()
  (IF (NULL #OBJ) (P-DE-QUI)
      (FOCUS-IT #OBJ)
      (COND
       ((PRESENT '(,#OBJ MAIN) DABA) (PRINZ 'JELTIEN 'BIEN 'MSIEU))
       ((PRESENT '(,#OBJ SUR !X) DABA)
        (IF (EQ X 'TERRE)
            (PRINZ 'PAR 'TERRE 'IL 'EST 'MSIEU)
            (PRINZ 'IL 'EST 'SUR X 'MSIEU)))
       ((PRESENT '(!X SUR ,#OBJ) DABA)  
        (PRINZ X 'EST 'SUR 'LUI 'MAIS #OBJ 'EST 'NULLE 'PART '/,
               'YA 'COMME 'CA 'DES 'OBJETS 'KISONT 'NULLE 'PART))
       (T (P-YAPAS #OBJ)))))

(DE IMPER-2 () (COND
  ((OR (NULL #OBJ) (NULL #LOC)) (P-DE-QUI))
  ((EQ #OBJ #LOC) (PRINZ 'PERSONNE 'Y 'PEU 'FAIRE 'UNE 'CHOSE 'COMME
       'CA 'MSIEU))
  ((EQ #REL 'SOUS) (P-ABSURDE))
  ((PRESENT '(,#OBJ MAIN) DABA)
   (IF (AND (NEQ #LOC 'TERRE) (PRESENT '(!X SUR ,#LOC) DABA))
       (PRINZ 'JPEUPA 'MSIEU 'YA X 'SUR #LOC)
       (OUT-DABA (LIST #OBJ 'MAIN)) (IN-DABA [#OBJ 'SUR #LOC])
       (FOCUS-IT #OBJ) (P-OUI-MSIEU)))
  ((PRESENT '(!X MAIN) DABA)
   (PRINZ 'CAISSE 'QUE 'JFAIS 'DE X 'MSIEU '/?) (FOCUS-IT X))
  ((PRESENT '(,#OBJ SUR !X) DABA)
   (FOCUS-IT #OBJ)
   (COND
     ((EQ X #LOC) (PRINZ 'ILYEST 'DEJA 'MSIEU))
     ((OR (PRESENT '(!X SUR ,#OBJ) DABA) (PRESENT '(!X SUR ,#LOC) DABA))
      (PRINZ 'JPEUPA 'MSIEU 'YA X 'DESSUS))
     (T (OUT-DABA [#OBJ 'SUR X]) (IN-DABA [#OBJ 'SUR #LOC])
        (P-OUI-MSIEU))))
  (T (P-YAPAS #OBJ)))))))))))))))))))))